home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / cont.c < prev    next >
C/C++ Source or Header  |  1992-10-27  |  8KB  |  293 lines
  1. /* Continuations and dynamic-wind.
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. /* The C library version of longjmp on the VAX unwinds the stack.
  7.  * As Jump_Cont below installs a new stack before calling longjmp,
  8.  * the standard version cannot be used.  The following simplistic
  9.  * version of setjmp/longjmp is used instead:
  10.  */
  11.  
  12. #if defined(vax) || defined(__vax__)
  13.   __asm__("    .globl  _setjmp");
  14.   __asm__("_setjmp:");
  15.   __asm__("    .word   0");
  16.   __asm__("    movl    4(ap),r0");
  17.   __asm__("    movq    r2,(r0)+");
  18.   __asm__("    movq    r4,(r0)+");
  19.   __asm__("    movq    r6,(r0)+");
  20.   __asm__("    movq    r8,(r0)+");
  21.   __asm__("    movq    r10,(r0)+");
  22.   __asm__("    movl    fp,(r0)+");
  23.   __asm__("    movq    4(fp),(r0)+");
  24.   __asm__("    movq    12(fp),(r0)+");
  25.   __asm__("    clrl    r0");
  26.   __asm__("    ret");
  27.  
  28.   __asm__("    .globl  _longjmp");
  29.   __asm__("_longjmp:");
  30.   __asm__("    .word   0");
  31.   __asm__("    movl    4(ap),r0");
  32.   __asm__("    movq    (r0)+,r2");
  33.   __asm__("    movq    (r0)+,r4");
  34.   __asm__("    movq    (r0)+,r6");
  35.   __asm__("    movq    (r0)+,r8");
  36.   __asm__("    movq    (r0)+,r10");
  37.   __asm__("    movl    (r0)+,r1");
  38.   __asm__("    movq    (r0)+,4(r1)");
  39.   __asm__("    movq    (r0)+,12(r1)");
  40.   __asm__("    movl    8(ap),r0");
  41.   __asm__("    movl    r1,fp");
  42.   __asm__("    ret");
  43. #endif
  44.  
  45. WIND *First_Wind, *Last_Wind;
  46.  
  47. static Object Cont_Value;
  48. #ifndef USE_ALLOCA
  49. static Object Cont_GCsave;
  50. #endif
  51.  
  52. /* Stack_Size returns the current stack size relative to stkbase.
  53.  * It works independent of the direction into which the stack grows
  54.  * (the stack grows upwards on HP-PA based machines and Pyramids).
  55.  */
  56. int Stack_Size () {
  57.     char foo;
  58.  
  59.     return &foo < stkbase ? stkbase-&foo : &foo-stkbase;
  60. }
  61.  
  62. Grow_Stack (cp, val) struct S_Control *cp; Object val; {
  63.     char buf[100];
  64.  
  65.     /* Prevent the optimizer from optimizing buf away:
  66.      */
  67.     bzero (buf, 100);
  68.  
  69.     Jump_Cont (cp, val);
  70. }
  71.  
  72. Jump_Cont (cp, val) struct S_Control *cp; Object val; {
  73.     static struct S_Control *p;
  74.     register char *from, *to;
  75.     register i;
  76.     char foo;
  77.     
  78. #if defined(sparc) || defined(__sparc__)
  79.     __asm__("t 0x3");   /* Flush register window */
  80. #endif
  81.     /* Reinstall the saved stack contents; take stack direction
  82.      * into account.  cp must be put into a static variable, as
  83.      * variables living on the stack cannot be referenced any
  84.      * longer after the new stack has been installed:
  85.      */
  86.     p = cp;
  87.     Cont_Value = val;
  88.     if (&foo < stkbase) {
  89.     if (stkbase - &foo < p->size) Grow_Stack (cp, val);
  90.     to = stkbase - p->size;
  91.     } else {
  92.     if (stkbase + p->size > &foo) Grow_Stack (cp, val);
  93.     to = stkbase;
  94.     }
  95.     from = p->stack;
  96.     for (i = p->size; i > 0; i--)
  97.     *to++ = *from++;
  98.     longjmp (p->j, 1);
  99. }
  100.  
  101. #ifndef USE_ALLOCA
  102. void Terminate_Cont (cont) Object cont; {
  103.     Free_Mem_Nodes (CONTROL(cont)->memlist);
  104. }
  105. #endif
  106.  
  107. Object P_Control_Pointp (x) Object x; {
  108.     return TYPE(x) == T_Control_Point ? True : False;
  109. }
  110.  
  111. Object P_Call_CC (proc) Object proc; {
  112.     register t;
  113.  
  114.     t = TYPE(proc);
  115.     if (t != T_Primitive && t != T_Compound && t != T_Control_Point)
  116.     Wrong_Type_Combination (proc, "procedure");
  117.     return Internal_Call_CC (0, proc);
  118. }
  119.  
  120. Object Internal_Call_CC (from_dump, proc) int from_dump; Object proc; {
  121.     Object control, ret, gcsave;
  122.     register struct S_Control *cp;
  123.     register char *p, *to;
  124.     register size;
  125.     GC_Node3;
  126.     char foo;
  127.  
  128.     control = gcsave = Null;
  129.     GC_Link3 (proc, control, gcsave);
  130. #ifndef USE_ALLOCA
  131.     gcsave = Save_GC_Nodes ();
  132. #endif
  133.  
  134.     size = Stack_Size ();
  135.     size = (size + 7) & ~7;
  136.     control = Alloc_Object (size + sizeof (struct S_Control) - 1,
  137.     T_Control_Point, 0);
  138.     cp = CONTROL(control);
  139.     cp->env = The_Environment;
  140.     cp->gclist = GC_List;
  141.     cp->firstwind = First_Wind;
  142.     cp->lastwind = Last_Wind;
  143.     cp->tailcall = Tail_Call;
  144.     cp->size = size;
  145.     cp->memsave = Null;
  146.     cp->gcsave = gcsave;
  147. #if defined(sparc) || defined(__sparc__)
  148.     __asm__("t 0x3");   /* Flush register window */
  149. #endif
  150.     /* Save the current stack contents; take stack direction
  151.      * into account.  delta holds the number of bytes by which
  152.      * the stack contents has been moved in memory (it is required
  153.      * to access variables on the saved stack later):
  154.      */
  155.     p = &foo < stkbase ? stkbase - cp->size : stkbase;
  156.     to = cp->stack;
  157.     bcopy (p, to, cp->size);
  158.     cp->delta = to - p;
  159. #ifndef USE_ALLOCA
  160.     Register_Terminate (control, Terminate_Cont);
  161.     Save_Mem_Nodes (control);
  162. #endif
  163.     if (setjmp (CONTROL(control)->j) != 0) {
  164. #ifndef USE_ALLOCA
  165.     Restore_GC_Nodes (Cont_GCsave);
  166. #endif
  167.     Enable_Interrupts;
  168.     return Cont_Value;
  169.     }
  170.     if (from_dump) {
  171. #ifdef CAN_DUMP
  172.     Dump_Control_Point = control;
  173. #endif
  174.     ret = False;
  175.     } else {
  176.     control = Cons (control, Null);
  177.     ret = Funcall (proc, control, 0);
  178.     }
  179.     GC_Unlink;
  180.     return ret;
  181. }
  182.  
  183. Funcall_Control_Point (control, argl, eval) Object control, argl; {
  184.     Object val, len, x;
  185.     register struct S_Control *cp;
  186.     register WIND *wp, *p;
  187.     register delta = 0;
  188.     GC_Node4;
  189.  
  190.     if (GC_In_Progress)
  191.     Fatal_Error ("jumping out of GC");
  192.     val = Null;
  193.     GC_Link4 (argl, control, val, x);
  194.     len = P_Length (argl);
  195.     if (FIXNUM(len) != 1)
  196.     Primitive_Error ("control point expects one argument");
  197.     val = Car (argl);
  198.     if (eval)
  199.     val = Eval (val);
  200.  
  201.     delta = CONTROL(control)->delta;
  202.     wp = CONTROL(control)->lastwind;
  203.     p = (WIND *)NORM(wp);
  204.     x = wp ? p->inout : Null;
  205.     for (wp = Last_Wind; wp && !EQ(wp->inout,x); wp = wp->prev)
  206.     Do_Wind (Cdr (wp->inout));
  207.  
  208.     for (wp = CONTROL(control)->firstwind; wp; ) {
  209.     delta = CONTROL(control)->delta;
  210.     p = (WIND *)NORM(wp);
  211.     if (First_Wind && EQ(p->inout,First_Wind->inout))
  212.         break;
  213.     wp = p->next;
  214.     Do_Wind (Car (p->inout));
  215.     }
  216.     GC_Unlink;
  217.     cp = CONTROL(control);
  218.     Switch_Environment (cp->env);
  219.     GC_List = cp->gclist;
  220. #ifndef USE_ALLOCA
  221.     Restore_Mem_Nodes (control);
  222.     Cont_GCsave = CONTROL(control)->gcsave;
  223. #endif
  224.     First_Wind = cp->firstwind;
  225.     Last_Wind = cp->lastwind;
  226.     Tail_Call = cp->tailcall;
  227.     Jump_Cont (cp, val);
  228.     /*NOTREACHED*/
  229. }
  230.  
  231. Do_Wind (w) Object w; {
  232.     Object oldenv, b, tmp;
  233.  
  234.     if (TYPE(w) == T_Vector) {          /* fluid-let */
  235.     oldenv = The_Environment;
  236.     Switch_Environment (VECTOR(w)->data[1]);
  237.     b = Lookup_Symbol (VECTOR(w)->data[0], 0);
  238.     if (Nullp (b))
  239.         Panic ("fluid-let");
  240.     tmp = VECTOR(w)->data[2];
  241.     VECTOR(w)->data[2] = Cdr (b);
  242.     Cdr (b) = tmp;
  243.     SYMBOL(Car (b))->value = tmp;
  244.     VECTOR(w)->data[1] = oldenv;
  245.     Switch_Environment (oldenv);
  246.     } else {                            /* dynamic-wind */
  247.     (void)Funcall (w, Null, 0);
  248.     }
  249. }
  250.  
  251. Add_Wind (w, in, out) register WIND *w; Object in, out; {
  252.     Object inout;
  253.     GC_Node2;
  254.  
  255.     GC_Link2 (in, out);
  256.     inout = Cons (in, out);
  257.     w->inout = inout;
  258.     w->next = 0;
  259.     if (First_Wind == 0)
  260.     First_Wind = w;
  261.     else
  262.     Last_Wind->next = w;
  263.     w->prev = Last_Wind;
  264.     Last_Wind = w;
  265.     GC_Unlink;
  266. }
  267.  
  268. Object P_Dynamic_Wind (in, body, out) Object in, body, out; {
  269.     WIND w, *first = First_Wind;
  270.     Object ret;
  271.     GC_Node4;
  272.  
  273.     Check_Procedure (in);
  274.     Check_Procedure (body);
  275.     Check_Procedure (out);
  276.     ret = Null;
  277.     GC_Link4 (in, body, out, ret);
  278.     Add_Wind (&w, in, out);
  279.     (void)Funcall (in, Null, 0);
  280.     ret = Funcall (body, Null, 0);
  281.     (void)Funcall (out, Null, 0);
  282.     if (Last_Wind = w.prev)
  283.     Last_Wind->next = 0;
  284.     First_Wind = first;
  285.     GC_Unlink;
  286.     return ret;
  287. }
  288.  
  289. Object P_Control_Point_Env (c) Object c; {
  290.     Check_Type (c, T_Control_Point);
  291.     return CONTROL(c)->env;
  292. }
  293.